COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Parser auxilliary routines }
C00004 00003	(* lookup functions: upperCase, eqStrng, hash, resLookup, idLookup, enterIdent *)
C00009 00004	(* aux routines: makeNewVar, makeUVar & varLookup *)
C00014 00005	(* aux routine: appendEnd *)
C00017 00006	(* aux routines for parsing expressions: defNode, getDtype, checkarg, copyExpr *)
C00023 00007	(* basic read routine: readLine *)
C00029 ENDMK
C⊗;
{$NOMAIN	Parser auxilliary routines }

%include palhdr.pas;

{ Externally defined routines from elsewhere: }

	(* From ALLOC *)
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;
procedure relIdent(n: identp);					external;
procedure relStrng(n: strngp);					external;
function newVaridef: varidefp;					external;
function newStatement: statementp;				external;

	(* Display-related Routines *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;
procedure ppDtype(d: datatypes);				external;

	(* From CALLER *)
function p1eReadLine(var line: linestr): integer;		external;

procedure pAux1Get; external;
procedure pAux1Get; begin end;
(* lookup functions: upperCase, eqStrng, hash, resLookup, idLookup, enterIdent *)

function upperCase(c: ascii): ascii; external;
function upperCase;
 begin
 if (c < chr(141B)) or (chr(172B) < c) then upperCase := c
  else upperCase := chr(ord(c) - 40B);		(* c - 'a' + 'A' *)
 end;

function eqStrng(s1: strngp; s2,len: integer): boolean; external;
function eqStrng;
 var i,j: integer; b: boolean; c1,c2: ascii;
 begin
 b := true;
 i := 0;
 j := 1;
 repeat
  c1 := upperCase(s1↑.ch[j]);
  c2 := upperCase(line[s2+i]);
  if c1 <> c2 then b := false
   else
    begin
    i := i + 1;
    if j < 10 then j := j + 1
     else begin j := 1; s1 := s1↑.next end;
    end
 until (i >= len) or not b;
 eqStrng := b;
 end;

function hash(ch: ascii): integer; external;
function hash;
 var i: integer;
 begin			(* this will only work for ascii *)
 i := ord(ch);
 if ('A' <= ch) and (ch <= 'Z') then i := i - ord('A') + 1
  else if (chr(141B) <= ch) and (ch <= chr(172B)) then i := i - 141B + 1
  else i := 0;
 hash := i;
 end;

function resLookup(str,len: integer): reswordp; external;
function resLookup;
 var res: reswordp; b: boolean;
 begin
 res := reswords[hash(line[str])];	(* look in right bucket *)
 b := true;
 while (res <> nil) and b do
  if res↑.length = len then
    if eqStrng(res↑.name,str,len) then b := false
     else res := res↑.next
   else res := res↑.next;
 resLookup := res;
 end;

function idLookup(str,len: integer): identp; external;
function idLookup;
 var id: identp; b: boolean;
 begin
 id := idents[hash(line[str])];		(* look in right bucket *)
 b := true;
 while (id <> nil) and b do
  if id↑.length = len then
    if eqStrng(id↑.name,str,len) then b := false
     else id := id↑.next
   else id := id↑.next;
 idLookup := id;
 end;

function getReswords(ch: ascii): reswordp; external;
function getReswords;
 begin
 getReswords := reswords[hash(ch)];	(* pass back right bucket *)
 end;

function getIdents(ch: ascii): identp; external;
function getIdents;
 begin
 getIdents := idents[hash(ch)];		(* pass back right bucket *)
 end;

(* aux routines: makeNewVar, makeUVar & varLookup *)

function makeNewVar(vartype: datatypes; vid: identp): varidefp; external;
function makeNewVar;
 var v: varidefp;
 begin
 v := newVaridef;
 with v↑ do
  begin
  vtype := vartype;
  dtype := nil;
  name := vid;
  next := nil;
  tbits := 0;
  dnext := nil;
  dbits := 0;
  s := nil;
  if curBlock <> nil then level := curBlock↑.level else level := 0;
  if curVariable <> nil then
    begin
    offset := curVariable↑.offset + 1;
    curVariable↑.next := v;	(* add var to current block's list of vars *)
    end
   else
    begin
    offset := 0;
    if curBlock <> nil then curBlock↑.variables := v;
    end;
  end;
 curVariable := v;
 makeNewVar := v;
 end;

function makeUVar(vartype: datatypes; vid: identp): varidefp; external;
function makeUVar;
 var v,oldCurVariable: varidefp; sp,oldCurBlock: statementp;
 begin
 oldCurVariable := curVariable;
 oldCurBlock := curBlock;
 curBlock := outerBlock;		(* assume outermost block *)
 v := curProc;			(* unless in body of an enclosing procedure *)
 while v <> nil do
  begin
  sp := oldCurBlock;
  while sp <> nil do
   if v↑.p↑.level + 1 = sp↑.level then
     begin curBlock := sp; v := nil; sp := nil end
    else if v↑.p↑.level >= sp↑.level then sp := nil else sp := sp↑.bparent;
  if v <> nil then v := v↑.dnext;
  end;
 curVariable := curBlock↑.variables;
 if curVariable <> nil then		(* find last defined variable *)
  while curVariable↑.next <> nil do curVariable := curVariable↑.next;
 v := makeNewVar(vartype,vid);
 sp := newStatement;	(* add a new declaration statement to start of block *)
 with sp↑ do
  begin
  stype := declaretype; variables := v; numvars := 1;
  last := curBlock; next := curBlock↑.bcode;
  end;
 if newDeclarations = nil then newDeclarations := sp;	(* for edit *)
 with curBlock↑ do 
  begin                                        (* splice us into block *)
  if bcode <> nil then bcode↑.last := sp;
  bcode := sp;
  end;
 curBlock := oldCurBlock;
 curVariable := oldCurVariable;
 makeUVar := v;
 end;

function varLookup(id: identp): varidefp; external;
function varLookup;
 var v,vp: varidefp; st: statementp; b,bp: boolean;
 begin
 st := curBlock;
 vp := curProc;
 bp := vp <> nil;
 b := true;
 while (st <> nil) and b do
  begin
  if bp then
    if vp↑.level = st↑.level then
      begin			(* check procedures parameter's *)
      v := vp↑.p↑.paramlist;
      vp := vp↑.dnext;		(* hack - up pointer to nesting proc defs *)
      bp := vp <> nil;
      end
     else
      begin			(* use block vars *)
      v := st↑.variables;
      st := st↑.bparent;
      end
   else	(* if dumb Pascal had short-circuit AND's this would be cleaner... *)
    begin			(* use block vars *)
    v := st↑.variables;
    st := st↑.bparent;
    end;
  while (v <> nil) and b do
   if v↑.name = id then b := false else v := v↑.next;
  end;
 if b then v := id↑.predefined;	(* maybe it's a predefined variable? *)
 varLookup := v;
 end;

(* aux routine: appendEnd *)

procedure appendEnd(s,so: statementp); external;
procedure appendEnd;
 var st: statementp;
 begin
 if so <> nil then
   begin
   st := newStatement;
   so↑.next := st;
   with st↑ do
    begin
    last := so;
    blkid := nil;
    stype := endtype;
    bparent := s;
    end;
   end;
 end;

(* aux routines for parsing expressions: defNode, getDtype, checkarg, copyExpr *)

 function defNode(d: datatypes): nodep; external;
 function defNode;
  var n: nodep;
  begin
  n := newNode;
  with n↑ do
   begin
   ntype := leafnode;
   ltype := d;
   case d of
svaltype: s := 0.0;
vectype:  v := nilvect;
rottype,
transtype: t := niltrans;
otherwise  {do nothing};
    end;
   end;
  defNode := n;
  end;

 function getDtype(n: nodep): datatypes; external;
 function getDtype;
  var da: datatypes;
  begin
  with n↑ do
   if ntype = leafnode then
     if ltype = varitype then da := vari↑.vtype
      else if ltype = pconstype then da := pcval↑.ltype
      else da := ltype
    else			(* see what type of op we've got *)
     if (svalop < op) and (op < vecop) or
	(ioop < op) and (op < specop) then da := svaltype else
     if (vecop < op) and (op < transop) then da := vectype else
     if (transop < op) and (op < ioop) then da := transtype else
     if (op = arefop) or (op = callop) then da := arg1↑.vari↑.vtype else
     if (op = grinchop) then da := getDtype(arg1) else
     if (op = vmop) or (op = adcop) then da := svaltype else
     if (op = badop) then da := getDtype(arg2) else da := nulltype;
  getDtype := da;
  end;

function checkArg(n: nodep; d: datatypes): nodep; external;
function checkArg;
 var bad: nodep; da: datatypes;
 begin
 if n = nil then checkArg := defNode(d)  (* use default value *)
  else
   begin
   da := getdtype(n);
   if (da <> d) and ((da = frametype) or (da = rottype)) then da := transtype;
   if (d = da) or ((d = rottype) and (da = transtype)) then
     checkArg := n			(* it's fine *)
    else if da = undeftype then
     begin				(* need to define the variable *)
     n↑.vari↑.vtype := d;
     checkArg := n;			(* but it's fine *)
     end
    else
     begin				(* no good - need to fix things up *)
     pp10L(' Found a  ',9); ppDtype(da);
     pp10(' where a  ',9); ppDtype(d);
     pp20(' should have been.  ',18);
     ppLine;
     bad := newNode;
     with bad↑ do
      begin
      ntype := exprnode;
      op := badop;
      arg1 := n;
      arg2 := defNode(d);
      arg3 := nil;
      end;
     checkArg := bad;
     end;
   end;
 end;

function copyExpr(n: nodep; lcp: boolean): nodep; external;
function copyExpr;
 var np: nodep;
 begin
 if n = nil then np := nil
  else
   with n↑ do
    begin
    if (ntype <> leafnode) or (ltype = varitype) or lcp then
      begin					(* need to make a copy *)
      np := newNode;
      np↑.ntype := ntype;
      case ntype of
arraydefnode:
       begin
       np↑.numdims := numdims;
       np↑.combnds := true;		(* indicate it's a copy *)
       np↑.bounds := copyexpr(bounds,false);
       end;
bnddefnode:
       begin
       np↑.next := copyexpr(next,false);
       np↑.lower := copyexpr(lower,false);
       np↑.upper := copyexpr(upper,false);
       end;
exprnode:
       begin
       np↑.op := op;
       if op = arefop then lcp := true;
       np↑.arg1 := copyexpr(arg1,false);
       np↑.arg2 := copyexpr(arg2,lcp);
       np↑.arg3 := copyexpr(arg3,false);
       end;
leafnode:
       begin
       np↑.ltype := ltype;
       np↑.length := length;		(* this should work for all leaftypes *)
       np↑.str := str
       end;
listnode:
       begin
       np↑.lval := copyexpr(lval,lcp);
       np↑.next := copyexpr(next,lcp);
       end;
otherwise {do nothing};
      end
     end
    else np := n;
   end;
 copyExpr := np;
 end;

(* basic read routine: readLine *)

procedure readline; external;
procedure readline;
 var i: integer;

procedure rdLine(var fi: atext);
 var ch: ascii; i,j: integer;

 procedure addit(c: c4str);
  var i: integer;
  begin
  if c[1] = ' ' then
    begin
    for i := 1 to 4 do line[maxchar+i] := c[i];
    ch := ' ';
    maxchar := maxchar + 4;
    end
   else
    begin
    line[maxchar] := c[1];
    ch := c[2];
    maxchar := maxchar + 1;
    end;
  end;

 begin
 maxchar := 0;
 if eofError or eof(fi) then
   begin
   if filedepth >= 1 then 
     begin			(* continue with last file *)
     filedepth := filedepth - 1;(* pop up a level *)
     ppLine;			(* give luser a sense of progress *)
     readline;			(* try again with popped file *)
     end
    else
     begin		     	(* yow - no file left - complain *)
     pp20L('*** End of File enco',20); pp20L('untered while parsin',20);
     pp10('g program ',10); ppLine;
     eofError := true;
     line[1] := 'E';		(* force parser to give up *)
     line[2] := 'N';
     line[3] := 'D';
     line[4] := ';';
     line[5] := ' ';
     curchar := 1;
     maxchar := 5;
     end
   end
  else
   begin			(* normal case - read in next line *)
   if eoln(fi) then readln(fi);
   while not eoln(fi) and (maxchar < 129) do
    begin
    maxchar := maxchar + 1;
    read(fi,line[maxchar]);
    if ord(line[maxchar]) = 11B then	(* turn tabs into spaces *)
      begin
      i := 8*(((maxchar - 1) div 8) + 1);
      for j := maxchar to i do line[j] := ' ';
      maxchar := i;
      end;
    end;
   line[maxchar+1] := ' ';	(* always can count on a final blank *)
   if line[1] <> chr(14B) then begin curchar := 1; curline := curline + 1; end
    else				(* new page *)
     begin
     curpage := curpage + 1;
     ppInt(curpage);		(* give luser a sense of progress *)
     ppChar(' ');
     ppOutNow;
     curline := 1;
     curchar := 2;
     line[1] := ' ';
     end;
   end;
 end;

 begin
  case filedepth of
0: begin
   maxChar := p1eReadLine(line);	
   curchar := 1; 
   end;
1: rdline(file1);
2: rdline(file2);
3: rdline(file3);
4: rdline(file4);
5: rdline(file5);
  end;
 shownline := false;
 end;